home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / XLISP 2.0 / XLISP Tools / Utility (UL) / STRING.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1988-04-07  |  8.6 KB  |  272 lines  |  [TEXT/ttxt]
  1. ;; Larry Mulcahy 1988
  2. ;; String functions and constants
  3.  
  4. (provide 'string)
  5. (require 'apl)
  6. (require 'math)
  7. (require 'sequence)
  8.  
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10. ; string-search
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12. ; return the 0-origin position of the first occurrence of the
  13. ; substring sub in the string s.
  14. ; If not found, return nil.
  15. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16.  
  17. (defun string-search (sub s) (string-search-helper sub s 0))
  18.  
  19. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20. ; string-search-helper
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22.  
  23. (defun string-search-helper (sub s deep)
  24.   (let
  25.     ((l-sub (length sub))
  26.      (l-s (length s)))
  27.     (if (> l-sub l-s)
  28.     nil
  29.         (if (equal (subseq s 0 l-sub) sub)
  30.         deep
  31.             (string-search-helper sub (string-rest s) (1+ deep))))))
  32.  
  33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34. ; string-substitute
  35. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36.  
  37. (defun string-substitute (old new s)
  38.   (if (= (length s) 0)
  39.       s
  40.       (let
  41.     ((where (string-search old s)))
  42.     (if where
  43.         (strcat
  44.           (subseq s 0 where)
  45.           new
  46.           (string-substitute old new (subseq s (+ where (length old)))))
  47.         s))))
  48.  
  49. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  50. ; string-left
  51. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  52. ; Like CAR for strings
  53. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  54.  
  55. (defun string-left (s) (char s 0))
  56.  
  57. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58. ; string-rest
  59. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  60. ; Like CDR for strings
  61. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62.  
  63. (defun string-rest (s) (subseq s 1))
  64.  
  65. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  66. ; to-string
  67. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  68.  
  69. (defun to-string (x)
  70. ; char->string from string-primitive module
  71.   (case (type-of x)
  72.     (fixnum (string (int-char x)))
  73.     (string x)    ; now handles characters
  74.     ))
  75.  
  76. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  77. ; list-of-characters-to-string
  78. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  79.  
  80. (defun list-of-characters-to-string (l)
  81.   (if l
  82.     (let ((stream (make-string-output-stream)))
  83.       (dolist (c l) (write-char c stream))
  84.       (get-output-stream-string stream))))
  85.  
  86. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  87. ; primitive-number-to-string
  88. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  89.  
  90. (defun primitive-number-to-string (n)
  91.   (let ((stream (make-string-output-stream)))
  92.     (princ n stream)
  93.     (get-output-stream-string stream)))
  94.  
  95. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96. ; *newline-string*
  97. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98. ; handy string consisting of one newline
  99. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  100.  
  101. (defconstant *newline-string* (string #\newline))
  102.  
  103. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  104. ; zap-to-string
  105. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  106.  
  107. (defun zap-to-string (uh)
  108.   (cond
  109.    ((listp uh) (list-to-string uh))
  110.    ((symbolp uh)
  111.     (let ((s (get uh 'as-a-string)))
  112.       (or s
  113.       (let ((s1 (string uh)))
  114.         (putprop uh s1 'as-a-string)
  115.         s1))))
  116.    ((numberp uh) (number-to-string uh))
  117.    (t (string uh))))
  118.  
  119. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  120. ; list-to-string
  121. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  122.  
  123. (defun list-to-string (l)
  124. ; concatenate from the sequence module
  125.   (if (null l)
  126.       ""
  127.     (if (equal (length l) 1)
  128.     (zap-to-string (car l))
  129.       (concatenate 'string
  130.     (zap-to-string (car l))
  131.     " "
  132.     (list-to-string (cdr l))))))
  133.  
  134.  
  135. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  136. ; number-to-string
  137. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  138.  
  139. (defun number-to-string (n)
  140. ; round from math module
  141. ; trim-float from math module
  142.   (case (type-of n)
  143.     (float (if (> (abs n) 100000.0)
  144.                (primitive-number-to-string (round n))
  145.          (if (< (abs n) 1.0) (format nil "~F" (trim-float n 8))
  146.            (format nil "~F" (trim-float n 2)))))
  147.  
  148. ; No ratios in XLISP yet
  149. ;    (ratio (if (> (abs n) 100)
  150. ;           (number-to-string (coerce n 'float))
  151. ;         (let* ((uh (multiple-value-list (truncate n)))
  152. ;            (whole (first uh))
  153. ;            (fraction (second uh)))
  154. ;           (if (= fraction 0)
  155. ;               (format nil "~D" whole)
  156. ;             (format nil "~D-~D" whole fraction)))))
  157.              
  158.     (t (primitive-number-to-string n))))
  159.  
  160. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  161. ; numbered-list-string
  162. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  163.  
  164. (defun numbered-list-string (l &key (indent 0) special)
  165. ; concatenate from the sequence module
  166. ; iota from apl module
  167.   (flet
  168.       ((formatter (x n)
  169.          (concatenate 'string
  170.            (make-string indent)
  171.            "["
  172.            (primitive-number-to-string n)
  173.            "] "
  174.            (if (and special (member x special :test #'equal))
  175.                (string-upcase (zap-to-string x))
  176.                (zap-to-string x))
  177.            *newline-string*)))
  178.     (apply #'concatenate
  179.            (cons 'string
  180.                  (mapcar #'formatter l (mapcar #'1+ (iota (length l))))))))
  181.  
  182. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  183. ; list-string
  184. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  185.  
  186. (defun list-string (l &key (indent 0) special)
  187.   (flet
  188.       ((formatter (x)
  189.          (concatenate 'string
  190.            (make-string indent)
  191.            (if (and special (member x special :test #'equal))
  192.                (string-upcase (zap-to-string x))
  193.                (zap-to-string x))
  194.            *newline-string*)))
  195.     (apply #'concatenate (cons 'string (mapcar #'formatter l)))))
  196.  
  197. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  198. ; *big-long-string*
  199. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  200.  
  201. (defconstant *big-long-string*
  202. ; concatenate from the sequence module
  203.   (let ((ten-spaces "          ")
  204.         (result ""))
  205.     (dotimes (i 100) (setq result (concatenate 'string ten-spaces result)))
  206.     result))
  207.  
  208. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  209. ; make-string
  210. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  211.  
  212. (defun make-string (big) (subseq *big-long-string* 0 big))
  213.  
  214. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  215. ; read-from-string
  216. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  217.  
  218. (defun read-from-string (string)
  219.   (read (make-string-input-stream string)))
  220.  
  221. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  222. ; remove-hyphens-and-downcase
  223. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  224.  
  225. (defun remove-hyphens-and-downcase (str)
  226. ; substitute from sequence module
  227.   (substitute #\space #\- (string-downcase str)))
  228.   
  229. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  230. ; *vowels*
  231. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  232.  
  233. (defvar *vowels* '(#\a #\e #\i #\o #\u))
  234.  
  235. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  236. ; begins-with-a-vowel-p 
  237. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  238.  
  239. (defun begins-with-a-vowel-p (string)
  240.   (member (char string 0) *vowels*))
  241.  
  242. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  243. ; word-plus-indefinite-article
  244. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  245.  
  246. (defun word-plus-indefinite-article (str)
  247.   (if (begins-with-a-vowel-p str)
  248.     (format nil "an ~A" str)
  249.     (format nil "a ~A" str)))
  250.  
  251. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  252. ; right-justify 
  253. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  254.  
  255. (defun right-justify (string field-width)
  256.   (let
  257.     ((big (length string)))
  258.     (if (< big field-width)
  259.         (concatenate 'string (make-string (- field-width big)) string)
  260.         string)))
  261.  
  262. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  263. ; left-justify 
  264. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  265.  
  266. (defun left-justify (string field-width)
  267.   (let
  268.     ((big (length string)))
  269.     (if (< big field-width)
  270.         (concatenate 'string string (make-string (- field-width big)))
  271.         string)))
  272.